;;;; Copyright 2009 Peter von Etter

;;;; This file is part of Autoproject

;;;; Autoproject is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation, either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; Autoproject is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with Autoproject.  If not, see
;;;; <http://www.gnu.org/licenses/>.

(in-package :autoproject.crud)

(defvar *buffer-size* 10000)

(defun select-mapc (crud select fn &key raw (buffer-size *buffer-size*))
  "Buffered mapc over selects.  If RAW is non-nil, the crud will be
queried using CRUD-SELECT-RAW, otherwise CRUD-SELECT"
  (let ((paged (merge-select (make-select :amount buffer-size
                                          :offset 0)
                             select))
        (query-fn (if raw
                      #'crud-select-raw
                      #'crud-select)))
    (loop :for sel = paged :then (select-next-page sel)
          :for stuff = (funcall query-fn crud sel)
          :do (when *debug* (print "buffering..."))
          :while stuff 
          :do (loop :for e :in stuff                          
                    :do (funcall fn e))))) 
  
(defun select-mapcar (crud select fn &key raw (buffer-size *buffer-size*))
  "Buffered mapcar over selects.  If RAW is non-nil, the crud will be
queried using CRUD-SELECT-RAW, otherwise CRUD-SELECT"
  (let (result)
    (select-mapc crud select
                 (lambda (x) (push (funcall fn x) result))
                 :raw raw
                 :buffer-size buffer-size)
    (nreverse result)))
  
(defun select-remove-if (crud select predicate 
                         &key raw (buffer-size *buffer-size*))
  "Buffered remove-if over selects.  If RAW is non-nil, the crud will be
queried using CRUD-SELECT-RAW, otherwise CRUD-SELECT"
  (let (result)
    (select-mapc crud select
                 (lambda (x)
                   (unless (funcall predicate x)
                     (push x result)))
                 :raw raw
                 :buffer-size buffer-size)
    (nreverse result)))


(defun make-buffer (producer-fn)
  "Returns a closure that will fill a buffer by calling PRODUCER-FN.
Each invocation of the closure pops one element off the buffer.  When
the buffer is empty, it is filled by calling PRODUCER-FN again.

For example, the call 

  (make-buffer (constantly '(1 2 3)))

will return a closure that returns 1, 2, 3 forever, in that order."
  (let ((buffer)
        (end))
    (lambda ()
      (unless end
        (if buffer
            (pop buffer)
            (let ((more-stuff (funcall producer-fn)))
              (when *debug* (print "buffering..."))
              (if more-stuff
                  (progn 
                    (setf buffer more-stuff)
                    (pop buffer))
                  (progn 
                    (setf end t)
                    nil))))))))

(defun select-buffered (crud select &key raw (buffer-size *buffer-size*))
  "Buffered iteration over selects.  Returns a closure that will
return elements from the database corresponding to SELECT.  If RAW
is non-nil, the crud will be queried using CRUD-SELECT-RAW,
otherwise CRUD-SELECT"
  (let ((paged (merge-select (make-select :amount buffer-size
                                          :offset 0)
                             select))
        (query-fn (if raw
                      #'crud-select-raw
                      #'crud-select)))
    
    (make-buffer (lambda ()
                   (let ((stuff (funcall query-fn crud paged)))
                     (setf paged (select-next-page paged))
                     stuff)))))


(defun %copy-bound-slots (from to)
  (loop :for s :in (get-slot-symbols from)
        :when (slot-boundp from s)                 
        :do (setf (slot-value to s)
                  (slot-value from s))))
                  
(defgeneric resolve-key (crud item foreign)
  (:documentation "
Returns the instance(s) from table FOREIGN-ITEM-NAME that is
referenced by ITEM.

Example:

  (resolve-key *crud* my-order 'customer)

This would return the customer referenced by my-order.

See ASSIGN-KEY and DEFINE-FOREIGN-KEY."))


(defgeneric assign-key (crud item foreign-item)
  (:documentation "
Links ITEM to FOREIGN-ITEM by setting slot values of ITEM in the way
specified by DEFINE-FOREIGN-KEY."))


(defmacro define-foreign-key ((item-class &rest item-slot-names)
                              (foreign-class &rest foreign-slot-names)
                              &key assign-key)
  "Defines a RESOLVE-KEY method for ITEM-CLASS and FOREIGN-CLASS.  If
ASSIGN-KEY is non-nil, also define an ASSIGN-KEY method.

Example:

  (define-foreign-key (order customer-id) (customer id) :assign-key t)

This would mean that order.customer_id references customer.id and that
assignment is allowed with ASSIGN-KEY.  Assigning a customer instance
to an order instance would mean setting the slot customer-id of the
order instance to the value of the id slot of customer instance."

  (let ((make-instance-list
         (loop :for a :in foreign-slot-names
            :for b :in item-slot-names
            :collect (intern (string a) :keyword)
            :collect `(slot-value item ',b)))
        
        (assign-list
         (when assign-key
           (loop :for a :in foreign-slot-names
              :for b :in item-slot-names
              :collect (intern (string b) :keyword)
              :collect `(slot-value foreign-item ',a)))))
    
    `(progn
       (defmethod resolve-key ((crud crud)
                               (item ,item-class)
                               (foreign-table (eql ',foreign-class)))
         (crud-match crud (make-instance ',foreign-class
                                         ,@make-instance-list)))
       
       (defmethod resolve-key ((crud crud)
                               (item ,item-class)
                               (foreign-partial ,foreign-class))
         (let ((o (make-instance ',foreign-class
                                 ,@make-instance-list)))
           (%copy-bound-slots foreign-partial o)              
           (crud-match crud o)))
       
       ,(when assign-key
              `(defmethod assign-key ((crud crud)
                                      (item ,item-class)
                                      (foreign-item ,foreign-class))
                 (let ((i (make-instance 
                           ',item-class 
                           :id (get-id item)
                           ,@assign-list)))
                   (crud-update-from-instance crud i)))))))
